{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lirio.Base.CatDoc
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Special Doc type for pretty printing LilyPond.
--
-- CatDoc only supports one type of concatenation @(<+>)@ and
-- allows reflective access to the head and tail elements - this 
-- enables a fairly simple implementation of beam grouping. 
--
--------------------------------------------------------------------------------


module Lirio.Base.CatDoc
  (

    CatDoc
  , renderCatDoc
  , plainNote
  , annoNote
  , typomark
  , newline
  , suffix
  , prefix

  ) where


import Text.PrettyPrint.Leijen                  -- package: wl-pprint

import Data.Monoid hiding ( (<>) ) 
import Data.Sequence ( Seq, ViewL(..), ViewR(..)
                     , viewl, viewr, singleton
                     , (><) )

-- | Glyph is bassically anything in a note list - 
-- notes, chords, rests, commands, bar line, repeat signs...
--
data Glyph = Glyph 
      { glyph_body      :: Doc
      , glyph_suffix    :: Doc
      }


-- | An note list element is either a @Glyph@ or a newline. 
-- Ideally note lists would just be glyphs but it is important 
-- to control line breaking in the output and we want to 
-- pattern-match on newlines as we render to avoid malformating
-- with the spacing @(<+>)@ combinator. 
--
data Elem = G Glyph
          | NEWLINE
  

newtype CatDoc = CatDoc { getCatDoc :: Seq Elem }

instance Monoid CatDoc where
  mempty        = CatDoc mempty
  a `mappend` b = CatDoc $ getCatDoc a >< getCatDoc b

renderCatDoc :: CatDoc -> Doc
renderCatDoc = stepA empty . viewl . getCatDoc
  where
    -- stepA - at start of line
    stepA ac EmptyL             = ac
    stepA ac (NEWLINE :< ss)    = stepA (ac <$> empty)          (viewl ss)
    stepA ac ((G gly) :< ss)    = stepB (ac <> renderGlyph gly) (viewl ss)

    -- stepB - within a line
    stepB ac EmptyL             = ac
    stepB ac (NEWLINE :< ss)    = stepA (ac <$> empty)           (viewl ss)
    stepB ac ((G gly) :< ss)    = stepB (ac <+> renderGlyph gly) (viewl ss)


renderGlyph :: Glyph -> Doc
renderGlyph gly = group $ glyph_body gly <> glyph_suffix gly



plainNote :: Doc -> CatDoc
plainNote d = CatDoc $ singleton $ G $ Glyph d empty

-- | Annotated note.
--
annoNote :: Doc -> Doc -> CatDoc
annoNote d a = CatDoc $ singleton $ G $ Glyph d a


-- | Typographic mark, e.g. a bar line or command.
--
typomark ::  Doc -> CatDoc
typomark = plainNote


newline :: CatDoc 
newline = CatDoc $ singleton $ NEWLINE



glyph :: Glyph -> CatDoc
glyph = CatDoc . singleton . G

-- getElem :: Elem -> Doc
-- getElem (Note n a) = n <> a
-- getElem (Glyph a)  = a 


leftview :: CatDoc -> Maybe (Elem,CatDoc)
leftview = step . viewl . getCatDoc
  where
    step EmptyL   = Nothing
    step (a :< s) = Just (a,CatDoc s)

rightview :: CatDoc -> Maybe (CatDoc,Elem)
rightview = step . viewr . getCatDoc
  where
    step EmptyR   = Nothing
    step (s :> a) = Just (CatDoc s,a)



annotateG :: Doc -> Glyph -> Glyph
annotateG suf (Glyph d a) = Glyph d (a <> suf)

suffix :: Doc -> CatDoc -> CatDoc
suffix d ss = case rightview ss of
    Just (front, NEWLINE) -> front `mappend` newline `mappend` plainNote d
    Just (front, G gly)   -> front `mappend` (glyph $ annotateG d gly)
    Nothing               -> mempty


prefix :: Doc -> CatDoc -> CatDoc
prefix d ss = case leftview ss of
    Just (NEWLINE, rest) -> plainNote d `mappend` newline `mappend` rest
    Just (G gly,   rest) -> (glyph $ annotateG d gly) `mappend` rest
    Nothing              -> mempty



